perm filename F2[E,ALS] blob
sn#255578 filedate 1976-12-28 generic text, type T, neo UTF8
CHESS: PROC OPTIONS (MAIN) REORDER;
SOLVE: PROC (MOVES, X) RECURSIVE RETURNS (BIT (1));
DCL (MOVES, X, PC, I, BECOME,
MINPIECE, MAXPIECE, PIECE, PCINDEX, SQUARE, TARGET, TEMP,
CAPTURED, BECOMEI, BECOMEJ, COLOR) BIN FIXED (31),
(ANSWER, CAN←MOVE) BIT (1);
COLOR = MOD(MOVES, 2);
IF COLOR=WHITE THEN MINPIECE=16; ELSE MINPIECE=0;
IF COLOR=WHITE THEN MAXPIECE=32; ELSE MAXPIECE=16;
CAN←MOVE = '0'B;
DO PC = 0 TO TOTAL(COLOR)-1;
PCINDEX = MOD (PC + MEMPC(MOVES), TOTAL(COLOR)) + 17*COLOR;
SQUARE = WHERE(PCINDEX);
IF SQUARE ¬= 0 THEN
DO;
PIECE = WHAT(PCINDEX);
CALL FIND←MOVES (SQUARE, PIECE, MINPIECE, MAXPIECE, BECOMEI,
BECOMEJ);
IF PC = 0 THEN
DO I = X+1 TO INDEX-1;
IF STACK(I) = MEMTAR(MOVES) THEN
DO;
STACK(I) = STACK(INDEX);
STACK(INDEX) = MEMTAR(MOVES);
END;
END;
BOARD(SQUARE) = -1;
DO WHILE (INDEX > X);
WHERE(PCINDEX), TARGET = STACK(INDEX);
INDEX = INDEX - 1;
CAPTURED = BOARD(TARGET);
WHERE(CAPTURED) = 0;
BOARD(TARGET) = PCINDEX;
IF ¬ INCHECK (COLOR) THEN
DO BECOME = BECOMEI TO BECOMEJ;
WHAT(PCINDEX) = BECOME;
CAN←MOVE = '1'B;
IF MOVES > PRINT THEN
DO;
PUT SKIP;
CALL PLAY (COLOR, PIECE, SQUARE, TARGET, CAPTURED,
BECOME);
END;
IF MOVES=0 THEN ANSWER='0'B; ELSE ANSWER=SOLVE
(MOVES-1, (INDEX));
IF ANSWER = (COLOR=WHITE) THEN
DO;
MEMPC(MOVES) = MEMPC(MOVES) + PC;
MEMTAR(MOVES) = TARGET;
IF MOVES = PRINT THEN
DO;
CALL PLAY (COLOR, PIECE, SQUARE, TARGET,
CAPTURED, BECOME);
WINPIECE = BECOME;
END;
BOARD(TARGET) = CAPTURED;
WHERE(CAPTURED) = TARGET;
BOARD(SQUARE) = PCINDEX;
WHERE(PCINDEX) = SQUARE;
WHAT(PCINDEX) = PIECE;
INDEX = X;
RETURN (ANSWER);
END;
END;
BOARD(TARGET) = CAPTURED;
WHERE(CAPTURED) = TARGET;
END;
BOARD(SQUARE) = PCINDEX;
WHERE(PCINDEX) = SQUARE;
WHAT(PCINDEX) = PIECE;
END;
END;
IF CAN←MOVE | COLOR=WHITE THEN RETURN (COLOR ¬= WHITE); ELSE
RETURN (INCHECK (BLACK));
END;
FIND←MOVES: PROC (SQUARE, PIECE, MINPIECE, MAXPIECE,
BECOMEI, BECOMEJ);
DCL (SQUARE, PIECE, MINPIECE, MAXPIECE, BECOMEI, BECOMEJ,
AHEAD, CAP, I) BIN FIXED (31);
FOLLOW: PROC (INCR);
DCL (INCR, AT) BIN FIXED (31);
AT = SQUARE + INCR;
DO WHILE (BOARD(AT) < 0);
CALL SET (AT);
AT = AT + INCR;
END;
IF ¬ ((BOARD(AT) >= MINPIECE) & (BOARD(AT) <= MAXPIECE)) THEN
CALL SET (AT);
END;
SET: PROC (X);
DCL X BIN FIXED (31);
INDEX = INDEX + 1;
STACK(INDEX) = X;
END;
BECOMEI, BECOMEJ = PIECE;
IF PIECE = PAWN THEN
DO;
IF MINPIECE=0 THEN AHEAD=10; ELSE AHEAD=-10;
IF MOD (SQUARE+AHEAD, 90) < 30 THEN
DO;
BECOMEI = QUEEN;
BECOMEJ = BISHOP;
END;
IF BOARD(SQUARE+AHEAD) < 0 THEN
DO;
CALL SET (SQUARE+AHEAD);
IF MOD (SQUARE-AHEAD, 90) < 30 &
(BOARD(SQUARE+2*AHEAD) < 0) THEN
CALL SET (SQUARE+2*AHEAD);
END;
DO I = -1, +1;
CAP = BOARD(SQUARE+AHEAD+I);
IF (CAP>=0) & ¬ ((CAP>=MINPIECE) & (CAP<=MAXPIECE)) THEN
CALL SET (SQUARE+AHEAD+I);
END;
END;
ELSE IF PIECE = KING THEN
DO I = -11, -10, -9, -1, +1, +9, +10, +11;
IF ¬((BOARD(SQUARE+I) >= MINPIECE) &
(BOARD(SQUARE+I) <= MAXPIECE)) THEN
CALL SET (SQUARE+I);
END;
ELSE IF PIECE = KNIGHT THEN
DO I = -21, -19, -12, -8, +8, +12, +19, +21;
IF ¬((BOARD(SQUARE+I) >= MINPIECE) &
(BOARD(SQUARE+I) <= MAXPIECE)) THEN
CALL SET (SQUARE+I);
END;
ELSE
DO;
IF PIECE ¬= BISHOP THEN
DO;
CALL FOLLOW (10); CALL FOLLOW (-10);
CALL FOLLOW (1); CALL FOLLOW (-1);
END;
IF PIECE ¬= ROOK THEN
DO;
CALL FOLLOW (11); CALL FOLLOW (-11);
CALL FOLLOW (9); CALL FOLLOW (-9);
END;
END;
END;
INCHECK: PROC (COLOR) RETURNS (BIT (1));
DCL (COLOR, KINGPOS, DIFF, BASE, ENEMY, BLOCK) BIN FIXED (31);
KINGPOS = WHERE(17*COLOR);
BASE = 17*(1-COLOR);
DO ENEMY = BASE TO BASE+TOTAL(1-COLOR)-1;
IF WHERE(ENEMY) ¬= 0 THEN
IF CKTYPE(WHAT(ENEMY)) = 1 THEN
DO;
DIFF = CKLINE(WHERE(ENEMY)-KINGPOS);
IF (DIFF ¬= 0) & (ROOKBISHOP(DIFF) ¬= WHAT(ENEMY)) THEN
DO;
DO BLOCK = KINGPOS+DIFF BY DIFF TO WHERE(ENEMY)-DIFF;
IF BOARD(BLOCK) >= 0 THEN
GO TO BLOCKED;
END;
RETURN ('1'B);
BLOCKED: END;
END;
ELSE IF CKTYPE(WHAT(ENEMY)) = 2 THEN
DO;
IF CKFROM(KINGPOS-WHERE(ENEMY)) = WHAT(ENEMY) THEN
RETURN ('1'B);
END;
ELSE
DO;
IF COLOR=BLACK THEN DIFF=10; ELSE DIFF=-10;
IF ABS (KINGPOS-WHERE(ENEMY)+DIFF) = 1 THEN
RETURN ('1'B);
END;
END;
RETURN ('0'B);
END;
SHOW: PROC;
DCL (COLOR, TYPE, I) BIN FIXED (31);
DO I = 0 TO 119;
IF BOARD(I) ¬= 16 THEN
DO;
IF BOARD(I) > 16 THEN COLOR=WHITE; ELSE COLOR=BLACK;
IF BOARD(I) >= 0 THEN TYPE=1+WHAT(BOARD(I)); ELSE TYPE=-1;
IF MOD (I, 10) = 1 THEN PUT SKIP (2);
IF TYPE < 0 THEN
PUT EDIT (SUBSTR (' . ', MOD (MOD (I, 10) +
FLOOR (I/10), 2)*4+1, 4)) (A);
ELSE IF COLOR = BLACK THEN
PUT EDIT (' (', SUBSTR (LTRS, NUM*COLOR+TYPE, 1), ')') (A);
ELSE
PUT EDIT (' ', SUBSTR (LTRS, NUM*COLOR+TYPE, 1), ' ') (A);
END;
END;
END;
PLAY: PROC (COLOR, PIECE, FROM, ONTO, CAPT, QUN);
DCL (COLOR, PIECE, FROM, ONTO, CAPT, QUN) BIN FIXED (31),
SP BIN FIXED (31) INIT (0);
PLACE: PROC (AT);
DCL AT BIN FIXED (31);
IF FLOOR (MOD (AT, 10) / 2) = 2 THEN
SP = SP + 1;
ELSE
PUT EDIT (SUBSTR ('QK', FLOOR (MOD (AT, 10) / 5)+1, 1)) (A);
PUT EDIT (SUBSTR ('RNBQKBNR', MOD (AT, 10), 1),
((11-2*FLOOR(AT/10)) * ((COLOR=WHITE)*2-1) + 9) / 2)
(A, F(1));
END;
PUT EDIT (SUBSTR (LTRS, NUM+PIECE+1, 1), '/') (A);
CALL PLACE (FROM);
IF CAPT < 0 THEN
DO;
PUT EDIT ('-') (A);
SP = SP + 2;
END;
ELSE
PUT EDIT ('x', SUBSTR (LTRS, NUM+WHAT(CAPT)+1, 1), '/') (A);
CALL PLACE (ONTO);
IF QUN ¬= PIECE THEN
PUT EDIT ('(', SUBSTR (LTRS, NUM+QUN+1, 1), ')') (A);
ELSE
SP = SP + 3;
IF INCHECK (1-COLOR) THEN
IF COLOR=WHITE & SOLVE (0, (INDEX)) THEN
PUT EDIT ('++') (A);
ELSE
PUT EDIT ('+ ') (A);
ELSE
PUT EDIT (' ') (A);
PUT EDIT (REPEAT (' ', SP)) (A);
END;
DCL ((WHAT, WHERE)(-1:32), BOARD (0:119), TOTAL (0:1)) BIN FIXED (31);
DCL LTRS CHAR (12) INIT ('kqnrbpKQNRBP'),
(KING INIT (0), QUEEN INIT (1), KNIGHT INIT (2), ROOK INIT (3),
BISHOP INIT (4), PAWN INIT (5), NUM INIT (6), WHITE INIT (1),
BLACK INIT (0), CKTYPE (0:5) INIT (2, 1, 2, 1, 1, 3),
(MEMPC, MEMTAR) (0:15) INIT ((16) 0),
(CKFROM INIT ((155) -1), CKLINE INIT ((155) 0)) (-77:+77),
ROOKBISHOP (-11:+11) INIT ((23) -1),
STACK (400), INDEX) BIN FIXED (31);
DCL CARD CHAR (80), POSITION CHAR (120) INIT ((120) '.'),
(MATEIN, TYPE, LOC, COLOR, WINPIECE, I, LINE, PRINT)
BIN FIXED (31);
DO I = 21, 19, 12, 8; CKFROM(I), CKFROM(-I) = KNIGHT; END;
DO I = 11, 10, 9, 1; CKFROM(I), CKFROM(-I) = KING; END;
DO LINE = -11, -10, -9, -1, +1, +9, +10, +11;
DO I = 1 TO 7; CKLINE(I*LINE) = LINE;
END; END;
DO I = 11, 9; ROOKBISHOP(I), ROOKBISHOP(-I) = ROOK; END;
DO I = 10, 1; ROOKBISHOP(I), ROOKBISHOP(-I) = BISHOP; END;
INDEX = 0;
GET EDIT (CARD, MATEIN) (A(79), F(1));
DO I = 0 TO 7;
SUBSTR (POSITION, 22+10*I, 8) = SUBSTR (CARD, 2+9*I, 8);
END;
DO I = 0 TO 1; TOTAL(I) = 17*I-1; END;
DO I = 0 TO 119;
IF SUBSTR (POSITION, I+1, 1) = '.' THEN
BOARD(I) = 16;
ELSE IF SUBSTR (POSITION, I+1, 1) = ' ' THEN
BOARD(I) = -1;
ELSE
DO;
TYPE = 0;
DO WHILE (SUBSTR (POSITION, I+1, 1) ¬= SUBSTR (LTRS, TYPE+1, 1));
TYPE = TYPE + 1;
END;
COLOR = TYPE / NUM;
LOC, TOTAL(COLOR) = TOTAL(COLOR) + 1;
IF (MOD (TYPE, NUM) = KING) & (LOC ¬= COLOR*17) THEN
DO;
WHAT(LOC) = WHAT(COLOR*17);
WHERE(LOC) = WHERE(COLOR*17);
BOARD(WHERE(LOC)) = LOC;
LOC = COLOR * 17;
END;
WHAT(LOC) = MOD (TYPE, NUM);
WHERE(LOC) = I;
BOARD(I) = LOC;
END;
END;
DO I = 0 TO 1; TOTAL(I) = TOTAL(I) - (17*I-1); END;
WHAT(16) = -1;
CALL SHOW;
PUT SKIP (3) EDIT (' WHITE TO PLAY AND MATE IN', MATEIN) (A, F(2));
PUT SKIP (5);
PRINT = 2*MATEIN-1;
IF ¬ SOLVE (PRINT, 0) THEN
PUT LIST ('NO SOLUTION.');
ELSE IF SUBSTR (CARD, 77, 2) ¬= ' ' THEN
DO;
PUT SKIP(2) EDIT ('IF: THEN:') (A);
LOC = 17 + MOD (MEMPC(PRINT), TOTAL(WHITE));
BOARD(WHERE(LOC)) = -1;
WHERE(LOC) = MEMTAR(PRINT);
WHERE(BOARD(WHERE(LOC))) = 0;
BOARD(WHERE(LOC)) = LOC;
WHAT(LOC) = WINPIECE;
INDEX = 0;
PRINT = PRINT-2;
IF ¬ SOLVE (PRINT+1, 0) THEN
PUT SKIP LIST ('***** ERROR *****');
END;
END;